perm filename MATCH.FLP[1,LMM] blob
sn#029045 filedate 1973-03-11 generic text, type T, neo UTF8
(FILECREATED "11-MAR-73 2:56:15")
(LISPXPRINT (QUOTE MATCHVARS)
T)
(RPAQQ MATCHVARS
((FNS MATCHELT MAKEMATCH MAKEEQ MAKEEQUAL MAKEOR MAKESETQ
CANMATCHNIL MAKEREPLACE SKIP$ MAKEMATCHEXP TSTMATCH
MAKEAND MAKECAR MAKECDR MAKENLEFT MAKESUBST MAKESUBST1
GENSYML EQTOMEMB MAKETSTLENGTH EASYTORECOMPUTE
MAKEEQLENGTH MAKENTH MAKEPLUS EXPANSION FULLEXPANSION
CRPX MAKEMATCHTOP MAKENOT MAKEMATCHFIXEDLEN MAKESOME
MATCHTAIL)
(VARS VARDEFAULT)))
(DEFINEQ
(MATCHELT
[LAMBDA (VAR PATELT MUSTBEMATCH ISVALUE)
(* This function matches VAR against PATELT when
PATELT is an "ELEMENT" pattern -
MUSTBEMATCH and ISVALUE have same meaning as in
MAKEMATCH)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
(("*" *)
(COND
((AND (NOT MUSTBEMATCH)
ISVALUE)
VAR)
(T (SETQ MUSTRETURN VAR)
T)))
($1 T)
(HELP "BAD PATTERN ELEMENT" PATELT)))
((NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
(DEFAULT (HELP
"DEFAULT SHOULD HAVE BEEN HANDLED IN ANALPAT"
"RETURN NIL TO DO IT NOW")
(MAKEDEFAULT PATELT)
(MATCHELT VAR PATELT MUSTBEMATCH ISVALUE))
(==(MAKEEQ VAR (CDR PATELT)))
['(MAKEEQUAL VAR (KWOTE (CDR PATELT]
(=(MAKEEQUAL VAR (CDR PATELT)))
[ANY (MAKEOR (MAPCAR (CDR PATELT)
(FUNCTION (LAMBDA (PE1)
(MATCHELT VAR PE1 T]
[←(MAKEAND (MATCHELT VAR (CDDR PATELT)
T)
(COND
((AND MUSTBEMATCH (CANMATCHNIL
(CDDR PATELT)))
(LIST (QUOTE OR)
(MAKESETQ (CADR PATELT)
VAR)
T))
(T (MAKESETQ (CADR PATELT)
VAR]
[-> (MAKEAND (MATCHELT VAR (CDDR PATELT)
T)
(COND
((AND MUSTBEMATCH (CANMATCHNIL
(CDDR PATELT)))
(LIST (QUOTE OR)
(MAKEREPLACE VAR (CADR PATELT))
T))
(T (MAKEREPLACE VAR (CADR PATELT]
(MAKEMATCH VAR PATELT MUSTBEMATCH ISVALUE)))
(T (MAKEMATCH VAR PATELT MUSTBEMATCH ISVALUE])
(MAKEMATCH
[LAMBDA (VAR PAT)
(PROG (SETS MATCH TEM TEM2 TEM3 TAIL (LEN 0))
(* Generate expresion which will match PAT against
VAR -
ISVALUE is a flag saying whether the expression
returned will be the value of the match
(for use in *'ed expressions) -
MUSTRETURN will be set to the expression that must
be returned, otherwise -
MUSTBEMATCH is a flag which says if the value of the
expression must be if no match occurs and non
otherwise -
It's used when expressions like SOME'S are incurred
-
Will return T if everything matches and either
MUSTBEMATCH is on or there is no sets involved -
($) as a pattern is an example)
(* AFFECTED BY GLOBALVARS: -
LISTPCHK IS ON IF A SUB-PATTERN SHOULD CHECK LISTP
FIRST -
NULLCHK IS ON IF CDRS SHOULD BE CHECKED IF NULL)
RETRY
(RETURN
(COND
((NULL PAT)
(COND
(NULLCHK (MAKENOT VAR))
(T T)))
[(NLISTP PAT)
(HELP "BAD PARSING")
(MAKEMATCH VAR (CONS '! (MAKEDEFAULT PAT]
((NOT (SETQ TEM2 (SKIP$ PAT))) (* PAT is a list of
$i's)
(COND
(NULLCHK (MAKEEQLENGTH VAR LEN))
(T)))
([AND (NOT (OR SETS MATCH (CDR TEM2)))
(FMEMB (CAR TEM2)
(QUOTE ($ -- ≠] (* PAT IS A LIST OF $I'S
FOLLOWED BY A $)
(COND
(NULLCHK (MAKETSTLENGTH VAR LEN))
(T)))
((NOT (EQ LEN 0)) (* PAT STARTS WITH A
LIST OF $I'S)
(MAKEMATCHEXP (MAKENTH VAR (MAKEPLUS 1 LEN))
TEM2))
[(EQ (ANALPATELT (CAR PAT))
(QUOTE ELT))
(MAKEAND (MATCHELT (MAKECAR VAR)
(CAR PAT))
(MAKEMATCH (MAKECDR VAR)
(CDR PAT]
((FMEMB (CAR PAT)
(QUOTE (≠ $ --)))
(MATCHTAIL VAR PAT))
((NLISTP (CAR PAT))
(HELP "BAD PATTERN ELEMENT" PAT))
((NLISTP (CAAR PAT))
(SELECTQ (CAAR PAT)
((DEFAULT = == ' PRED)
(HELP "SHOULDN'T GET HERE"))
[← (* Only segment SETS get
here)
(COND
((NOT (CDR PAT))
(MAKEAND (MAKEMATCH VAR
(LIST (CDDAR PAT)))
(MAKESETQ (CADAR PAT)
VAR)))
(T (HELP "CAN'T DO SEGMENT SET YET"]
(-> (* Only segmentreplaces
get here)
(HELP "CAN'T REPLACE A SEGMENT YET"))
(ANY (* Segment any's go
here)
(HELP "CAN'T DO AN ANY WHEN "
"SOME ARE SEGMENTS"))
[! (COND
((NULL (CDR PAT))
(MATCHELT VAR (CDAR PAT)))
(T (HELP "WHAT'S THIS AFTER !" PAT]
($$ (HELP "$$ NOT WORKING" PAT)
(MAKEMATCHEXP (MAKENTH VAR (CDAR PAT))
(CDR PAT)))
(HELP "WHAT'S THIS" PAT)))
(T (HELP "WHAT'S HERE" PAT])
(MAKEEQ
[LAMBDA (VAR EXPRESSION)
(LIST (QUOTE EQ)
VAR EXPRESSION])
(MAKEEQUAL
[LAMBDA (VAR EXPRESSION)
(LIST (COND
([OR (SMALLP EXPRESSION)
(AND (EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(OR (SMALLP (CADR EXPRESSION))
(LITATOM (CADR EXPRESSION]
(QUOTE EQ))
((NUMBERP EXPRESSION)
(QUOTE EQP))
(T (QUOTE EQUAL)))
VAR EXPRESSION])
(MAKEOR
[LAMBDA (EXPRLIST)
(CONS (QUOTE OR)
EXPRLIST])
(MAKESETQ
[LAMBDA (VAR EXPRESSION)
(COND
((OR (NUMBERP VAR)
(NOT VAR)
(LISTP VAR))
(HELP "TRYING TO SET NON-VARIABLE" VAR)))
(LIST (QUOTE SETQ)
VAR EXPRESSION])
(CANMATCHNIL
[LAMBDA (PATELT)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
(($1 *)
T)
($)
T))
((NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
[$$ (NOT (AND (NUMBERP (CDR PATELT))
(IGREATERP (CDR PATELT)
1]
((←
->)
(CANMATCHNIL (CDDR PATELT)))
(!
(* This isn't really right, but i'm too lazy to do
the analysys and will assume it can match NIL)
T)
('(NOT (CDR PATELT)))
((= ==)
T)
(ANY (SOME (CDR PATELT)
(FUNCTION CANMATCHNIL)))
NIL))
(T NIL])
(MAKEREPLACE
[LAMBDA (VAR EXPR)
(SETQ VAR (FULLEXPANSION VAR))
(COND
((EQ (CAR VAR)
(QUOTE CAR))
(LIST (QUOTE RPLACA)
(CADR VAR)
EXPR))
((EQ (CAR VAR)
(QUOTE CDR))
(LIST (QUOTE RPLACD)
(CADR VAR)
EXPR))
[(EQ (CAR VAR)
(QUOTE LDIFF))
(MAKEREPLACE (CADR VAR)
(LIST (QUOTE NCONC)
EXPR
(CADDR VAR]
(T (HELP "HOW TO REPLACE" VAR])
(SKIP$
[LAMBDA (PAT SETOK MATCHOK TAIL)
(* SCANS PAT UNTIL ONE OF THE FOLLOWING CONDITIONS
OCCURS: -
(1) TAIL IS HIT -
(2) A PATTERN ELEMENT WHICH MATCHES AN ARBITRARY
LENGTH SEGMENT IS HIT -
(3) SETOK IS NIL AND A PATTERN ELMENT INVOLVING A ←
IS HIT -
(4) MATCHOK IS NIL AND A PATTERN ELMENT INVOLVING A
"MATCH" OF ANYKIND IS HIT -
(5) THE END OF PAT IS REACHED)
(* The free variables SETS and MATCH are set to T if
a set or MATCH (respectively) are found in any of
the pattern elements passed over)
(PROG (OLDSET OLDMATCH)
LP (SETQ OLDSET SETS)
(SETQ OLDMATCH MATCH)
[COND
((OR (NULL PAT)
(EQ PAT TAIL))
(RETURN PAT))
((OR (EQ (SETQ TEM (ANALPATELT (CAR PAT)
T))
(QUOTE ARB))
(AND (NOT SETOK)
SETS)
(AND (NOT MATCHOK)
MATCH))
(SETQ SETS OLDSET)
(SETQ MATCH OLDMATCH)
(RETURN PAT))
(T (SETQ LEN (MAKEPLUS TEM LEN]
(SETQ PAT (CDR PAT))
(GO LP])
(MAKEMATCHEXP
[LAMBDA (VAR PAT)
(* CALL THIS FUNCTION INSTEAD OF MAKEMATCH IF THE
VAR MIGHT NOT BE EASY TO RECOMPUTE)
(PROG (MUSTRETURN EXPRESSION)
(COND
((EASYTORECOMPUTE VAR)
(SETQ EXPRESSION (MAKEMATCH VAR PAT))
(COND
(MUSTRETURN (MAKEAND EXPRESSION MUSTRETURN))
(T EXPRESSION)))
(T (MAKESUBST (SETQ TEM2 (GENSYML VAR))
VAR
(PROGN (SETQ EXPRESSION (MAKEMATCH TEM2 PAT))
(COND
(MUSTRETURN (MAKEAND EXPRESSION
MUSTRETURN))
(T EXPRESSION])
(TSTMATCH
[LAMBDA NIL
(PROG (TEM (NULLCHK T)
(LISTPCHK T)
(ISVALUE T)
MUSTBEMATCH)
LP (PRIN1 "PATTERN? " T)
(COND
((NOT (SETQ TEM (LISPXREAD T)))
(RETURN)))
(LISPXPRIN1 "PATTERN? " T NIL T)
(LISPXPRINT (COPY TEM)
T NIL T)
(LISPXTERPRI T)
[COND
((EQ TEM (QUOTE E))
(LISPXPRINT (EVAL (LISPXREAD T))
T)
(GO LP))
((EQ TEM (QUOTE G))
(SETQ TEM (LISPXPRINT (UNPARSE (PROG (STARDONE)
(PAT)))
T]
(LISPXTERPRI T)
(LISPXPRINTDEF (MAKEMATCHTOP (QUOTE X)
(LISPXPRINT (PARSE TEM)
T)
ISVALUE MUSTBEMATCH)
1 T)
(LISPXTERPRI T)
(LISPXTERPRI)
(GO LP])
(MAKEAND
[LAMBDA (EXPR1 EXPR2)
(COND
((EQ EXPR1 T)
EXPR2)
((EQ EXPR2 T)
EXPR1)
[(EQ (CAR EXPR2)
(QUOTE AND))
(CONS (QUOTE AND)
(CONS EXPR1 (CDR EXPR2]
[(EQ (CAR EXPR1)
(QUOTE AND))
(CONS (QUOTE AND)
(APPEND (CDR EXPR1)
(LIST EXPR2]
(T (LIST (QUOTE AND)
EXPR1 EXPR2])
(MAKECAR
[LAMBDA (X)
(PROG [(TEM (FASSOC (CAR X)
(QUOTE ((CAR . CAAR)
(CDR . CADR)
(CAAR . CAAAR)
(CADR . CAADR)
(CDAR . CADAR)
(CDDR . CADDR)
(CAAAR . CAAAAR)
(CAADR . CAAADR)
(CADAR . CAADAR)
(CADDR . CAADDR)
(CDAAR . CADAAR)
(CDADR . CADADR)
(CDDAR . CADDAR)
(CDDDR . CADDDR]
(COND
(TEM (LIST (CDR TEM)
(CADR X)))
(T (LIST (QUOTE CAR)
X])
(MAKECDR
[LAMBDA (X)
(PROG [(TEM (FASSOC (CAR X)
(QUOTE ((CAR . CDAR)
(CDR . CDDR)
(CAAR . CDAAR)
(CADR . CDADR)
(CDAR . CDDAR)
(CDDR . CDDDR)
(CAAAR . CDAAAR)
(CAADR . CDAADR)
(CADAR . CDADAR)
(CADDR . CDADDR)
(CDAAR . CDDAAR)
(CDADR . CDDADR)
(CDDAR . CDDDAR)
(CDDDR . CDDDDR]
(COND
(TEM (LIST (CDR TEM)
(CADR X)))
(T (LIST (QUOTE CDR)
X])
(MAKENLEFT
[LAMBDA (EXPR N)
(COND
((EQ N 1)
(LIST (QUOTE LAST)
EXPR))
(T (LIST (QUOTE NLEFT)
EXPR N])
(MAKESUBST
[LAMBDA (OLD NEW EXPR)
(PROG ((SAVNEW NEW)
FORM FOUNDBEFORE)
(COND
((EQ OLD EXPR)
(RETURN NEW)))
[SETQ FORM (MAKESUBST1 (SETQ EXPR (COPY EXPR]
(RETURN (COND
((EQ FOUNDBEFORE T)
(LIST (QUOTE PROG)
(LIST (LIST NEW SAVNEW))
(LIST (QUOTE RETURN)
EXPR)))
(T EXPR])
(MAKESUBST1
[LAMBDA (EXPR)
(COND
((NLISTP EXPR)
EXPR)
([OR (EQUAL (CAR EXPR)
OLD)
(AND (EQ (CAR OLD)
(QUOTE *ANY*))
(MEMBER (CAR EXPR)
(CDR OLD]
(COND
((NOT FOUNDBEFORE)
(SETQ FOUNDBEFORE EXPR))
((EQ FOUNDBEFORE T))
(T (RPLACA FOUNDBEFORE (SETQ NEW (GENSYML OLD)))
(SETQ FOUNDBEFORE T)))
(RPLACA EXPR NEW)
(MAKESUBST1 (CDR EXPR)))
(T (MAKESUBST1 (CAR EXPR))
(MAKESUBST1 (CDR EXPR))
EXPR])
(GENSYML
[LAMBDA (X)
(PACK (LIST "TEM#" (SETQ GENSYMCNT
(ADD1 (OR (NUMBERP (CAR (QUOTE GENSYMCNT)))
0])
(EQTOMEMB
[LAMBDA (EXPR)
(OR [CAR (NLSETQ (EDITE EXPR (CONS [COND
((EQ (CAR EXPR)
(QUOTE EQ))
(QUOTE (1 MEMB)))
(T (QUOTE (1 MEMBER]
(QUOTE ((SW 2 3]
(HELP "BAD EQ EXPR IN EQTOMEMB" EXPR])
(MAKETSTLENGTH
[LAMBDA (X N)
(COND
((NOT (NUMBERP N))
(LIST (QUOTE NTH)
X N))
((ZEROP N)
T)
((EQ N 1)
X)
(T (MAKETSTLENGTH (MAKECDR X)
(SUB1 N])
(EASYTORECOMPUTE
[LAMBDA (EXPR)
(OR (NLISTP EXPR)
(AND [OR (GETP (CAR EXPR)
(QUOTE CROPS))
(FMEMB (CAR EXPR)
(QUOTE (CAR CDR]
(EASYTORECOMPUTE (CADR EXPR])
(MAKEEQLENGTH
[LAMBDA (VAR LEN)
(COND
((EQ LEN 0)
(LIST (QUOTE NOT)
VAR))
((EQ LEN 1)
(MAKEAND VAR (MAKEEQLENGTH (MAKECDR VAR)
0)))
((NUMBERP LEN)
(MAKEEQLENGTH (MAKECDR VAR)
(SUB1 LEN)))
(T (LIST (QUOTE EQ)
(LIST (QUOTE LENGTH)
VAR)
LEN])
(MAKENTH
[LAMBDA (PAT LEN)
(COND
((NOT (NUMBERP LEN))
(LIST (QUOTE NTH)
PAT LEN))
((ZEROP LEN)
T)
((EQ LEN 1)
PAT)
(T (MAKENTH (MAKECDR PAT)
(SUB1 LEN])
(MAKEPLUS
[LAMBDA (EXPR1 EXPR2)
(PROG ((SUM 0)
LIST)
[SETQ LIST (NCONC (COND
[(EQ (CAR EXPR1)
(QUOTE IPLUS))
(MAPCONC (CDR EXPR1)
(FUNCTION (LAMBDA (X)
(COND
((NUMBERP X)
(SETQ SUM
(IPLUS SUM X))
NIL)
(T (LIST X]
((NUMBERP EXPR1)
(SETQ SUM (IPLUS SUM EXPR1))
NIL)
(T (LIST EXPR1)))
(COND
[(EQ (CAR EXPR2)
(QUOTE IPLUS))
(MAPCONC (CDR EXPR2)
(FUNCTION (LAMBDA (X)
(COND
((NUMBERP X)
(SETQ SUM
(IPLUS SUM X))
NIL)
(T (LIST X]
((NUMBERP EXPR2)
(SETQ SUM (IPLUS SUM EXPR2))
NIL)
(T (LIST EXPR2]
(COND
((NULL LIST)
SUM)
((IGREATERP SUM 0)
(CONS (QUOTE IPLUS)
(CONS SUM LIST)))
((NOT (CDR LIST))
(CAR LIST))
(T (CONS (QUOTE IPLUS)
LIST])
(EXPANSION
[LAMBDA (FORM)
(PROG [(MACVAL (GETP (CAR FORM)
(QUOTE MACRO]
(COND
((NOT MACVAL)
FORM)
((MEMB (CAR MACVAL)
(QUOTE [LAMBDA NLAMBDA]))
(CONS MACVAL (CDR FORM)))
[(AND (CAR MACVAL)
(ATOM (CAR MACVAL)))
(EVALA (CADR MACVAL)
(LIST (CONS (CAR MACVAL)
(CDR FORM]
(T (SUBPAIR (CAR MACVAL)
(CDR FORM)
(CADR MACVAL])
(FULLEXPANSION
[LAMBDA (X)
(SETQ X (EXPANSION X))
(COND
[(CDR (GETP (CAR X)
(QUOTE CROPS)))
(CRPX (CADR X)
(GETP (CAR X)
(QUOTE CROPS]
(T X])
(CRPX
[LAMBDA (DEF XL)
(COND
((NOT XL)
DEF)
(T (LIST (SELECTQ (CAR (SETQ XL (REVERSE XL)))
(A (QUOTE CAR))
(D 'CDR)
(HELP))
(COND
((CDR XL)
(LIST (PACK (CONS "C" (NCONC1 (CDR XL)
"R")))
DEF))
(T DEF])
(MAKEMATCHTOP
[LAMBDA (VAR PAT ISVALUE MUSTBEMATCH)
(PROG (MUSTRETURN EXPRESSION (TOPNULLCHK NULLCHK))
(SETQ EXPRESSION (MAKEMATCH VAR PAT))
(COND
(MUSTRETURN (MAKEAND EXPRESSION MUSTRETURN))
(T EXPRESSION])
(MAKENOT
[LAMBDA (X)
(COND
((MEMB (CAR X)
(QUOTE (NOT NULL)))
(CADR X))
(T (LIST (QUOTE NOT)
X])
(MAKEMATCHFIXEDLEN
[LAMBDA (VAR PAT)
(* This function is called when it is known that if
any element of VAR is non NIL, then VAR is of the
right length to MATCH PAT and so no length tests
need be performed)
(PROG (NULLCHK)
(COND
((NOT (EVERY PAT (FUNCTION CANMATCHNIL)))
(MAKEMATCHEXP VAR PAT))
((EASYTORECOMPUTE VAR)
(MAKEAND VAR (MAKEMATCH VAR PAT)))
(T (MAKESUBST (SETQ TEM2 (GENSYML VAR))
VAR
(MAKEAND TEM2 (MAKEMATCH TEM2 PAT])
(MAKESOME
[LAMBDA (LIST VAR EXPR)
(PROG (VAR2)
(LIST (QUOTE SOME)
LIST
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
(LIST (SETQ VAR2 (GENSYML VAR))
VAR)
(MAKESUBST (MAKECAR VAR)
VAR2 EXPR])
(MATCHTAIL
[LAMBDA (VAR PAT)
(PROG (MATCH SETS)
(COND
((NOT (SETQ TAIL (SKIP$ (CDR PAT)
T T))) (* PAT is $ followed by
a bunch of fixed-length
items)
(COND
((OR MATCH SETS)
(MAKEMATCHFIXEDLEN (MAKENLEFT VAR LEN)
(CDR PAT)))
(NULLCHK (MAKETSTLENGTH VAR LEN))
(T)))
[(AND (FMEMB (CAADR PAT)
(QUOTE (' = ==)))
(PROG (SETS MATCH (PAT2 (CDDR PAT)))
(* Check if PAT ends is ($ 'foo nomatch nomatch ...
Arb-nomatch ...))
LP (COND
((NULL PAT2)
(RETURN))
((AND (OR (EQ (SETQ TEM3 (ANALPATELT
(CAR PAT2)))
(QUOTE ELT))
(NUMBERP TEM3))
(NOT MATCH))
(SETQ PAT2 (CDR PAT2)))
((AND (NOT MATCH)
(EQ TEM3 (QUOTE ARB)))
(RETURN PAT2))
(T (RETURN)))
(GO LP)))
(MAKEMATCHEXP (EQTOMEMB (MATCHELT VAR (CADR PAT)))
(CONS (QUOTE $1)
(CDDR PAT]
((PROG (MATCH)
(AND (EQ (ANALPATELT (CADR PAT))
(QUOTE ARB))
(NOT MATCH)))
(HELP "TWO ARB PATTERNS IN A ROW" PAT))
(T (MAKESOME VAR (SETQ TEM (GENSYML VAR))
(MAKEMATCHTOP TEM (CDR PAT)
NIL T])
)
(RPAQQ VARDEFAULT SET)
STOP